home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / menubar.lsp < prev    next >
Lisp/Scheme  |  1990-06-01  |  3KB  |  91 lines
  1. ;;;;
  2. ;;;;
  3. ;;;; menubar.lsp Menus for the Amiga
  4. ;;;; XLISP-STAT 2.0 Copyright (c) 1988, by Luke Tierney
  5. ;;;;    All Rights Reserved
  6. ;;;;    Permission is granted for unrestricted non-commercial use
  7. ;;;; Additions to
  8. ;;;; Xlisp 2.0 Copyright (c) 1985, 1987 by David Michael Betz
  9. ;;;;
  10. ;;;;
  11.  
  12. (provide "menubar")
  13.  
  14. ;;;;
  15. ;;;; General Menu Methods and Functions
  16. ;;;;
  17.  
  18. (defmeth menu-proto :find-item (str)
  19. "Method args: (str)
  20. Finds and returns menu item with title STR."
  21.   (dolist (item (send self :items))
  22.     (if (string-equal str (send item :title)) (return item))))
  23.  
  24. (defun find-menu (title)
  25. "Args: (title)
  26. Finds and returns menu in the menu bar with title TITLE."
  27.   (dolist (i *hardware-objects*)
  28.           (let ((object (nth 2 i)))
  29.             (if (and (kind-of-p object menu-proto) 
  30.                      (send object :installed-p) 
  31.                      (string-equal (string title) (send object :title)))
  32.                 (return object)))))
  33.  
  34. (defun set-menu-bar (menus)
  35. "Args (menus)
  36. Makes the list MENUS the current menu bar."
  37.   (dolist (i *hardware-objects*)
  38.           (let ((object (nth 2 i)))
  39.             (if (kind-of-p object menu-proto) (send object :remove))))
  40.   (dolist (i menus) (send i :allocate) (send i :install)))
  41.  
  42. ;;;;
  43. ;;;; File Menu
  44. ;;;;
  45.  
  46. (defvar *file-menu* (send menu-proto :new "File"))
  47.  
  48. (defproto file-edit-item-proto '(message) '() menu-item-proto)
  49.  
  50. (defmeth file-edit-item-proto :isnew (title message &rest args)
  51.   (setf (slot-value 'message) message)
  52.   (apply #'call-next-method title args))
  53.   
  54. (defmeth file-edit-item-proto :do-action ()
  55.   (send (front-window) (slot-value 'message)))
  56.  
  57. (defmeth file-edit-item-proto :update ()
  58.   (send self :enabled (kind-of-p (front-window) edit-window-proto)))
  59.  
  60. (send *file-menu* :append-items 
  61.   (send menu-item-proto :new "Load" :key #\L :action
  62.     #'(lambda ()
  63.       (let ((f (open-file-dialog t)))
  64.         (when f (load f) (format t "; finished loading ~s~%" f)))))
  65.   (send dash-item-proto :new)
  66.   (send menu-item-proto :new "Quit" :key #\Q :action 'exit))
  67.  
  68. ;;;;
  69. ;;;; Command Menu
  70. ;;;;
  71.  
  72. (defvar *command-menu* (send menu-proto :new "Command"))
  73. (send *command-menu* :append-items
  74.   (send menu-item-proto :new "Clean Up" :key #\, :action #'clean-up)
  75.   (send menu-item-proto :new "Toplevel" :key #\. :action #'top-level)
  76.   (send dash-item-proto :new)
  77.   (let ((item (send menu-item-proto :new "Dribble" :key #\D)))
  78.     (send item :action 
  79.         #'(lambda () 
  80.             (cond
  81.               ((send item :mark) (dribble) (send item :mark nil))
  82.               (t (let ((f (set-file-dialog "Dribble file:")))
  83.                    (when f
  84.                          (dribble f)
  85.                          (send item :mark t)))))))
  86.     item))
  87.  
  88. (defconstant *standard-menu-bar* (list  *file-menu* *command-menu*))
  89.  
  90. (set-menu-bar *standard-menu-bar*)
  91.